home *** CD-ROM | disk | FTP | other *** search
/ ASME's Mechanical Engine…ing Toolkit 1997 December / ASME's Mechanical Engineering Toolkit 1997 December.iso / auto_cad / clip.lsp < prev    next >
Text File  |  1992-04-07  |  9KB  |  268 lines
  1. ;----------------------------------------------------------
  2. ; CLIP.LSP -- Copyright 1988 by Looking Glass Microproducts
  3. ;----------------------------------------------------------
  4. ; MODES
  5. ; System variable save
  6. (defun modes (a)
  7.    (setq MLST nil)
  8.    (repeat (length a)
  9.       (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  10.       (setq a (cdr a)) ) )
  11. ;----------------------------------------------------------
  12. ; System variable restore
  13. (defun moder ()
  14.    (repeat (length MLST)
  15.       (setvar (caar MLST) (cadar MLST))
  16.       (setq MLST (cdr MLST)) ) )
  17. ;----------------------------------------------------------
  18. ; Delta x y
  19. (defun dxy (p dx dy)
  20.   (list
  21.      (+ dx (car p))
  22.      (+ dy (cadr p)) ) )
  23. ;--------------------------------------------------------
  24. ; Item from association list
  25. (defun item (n alist)
  26.   (cdr (assoc n alist) ) )
  27. ;--------------------------------------------------------
  28. ; Midpoint between two points
  29. (defun midpoint (p1 p2)
  30.   (mapcar
  31.       '(lambda (x1 x2)
  32.                (* 0.5 (+ x1 x2)))
  33.        p1 p2) )
  34. ;----------------------------------------------------------
  35. ; TRIM entities on points outside boundary
  36. (defun trim (ename p)
  37.    (setq fuzz 1E-6)
  38.    (if (not
  39.           (and
  40.              (<= (- x0 fuzz) (car p)  (+ x2 fuzz))
  41.              (<= (- y0 fuzz) (cadr p) (+ y2 fuzz))))
  42.        (progn
  43.          (command (list ename p))
  44.          T) ) )
  45. ;----------------------------------------------------------
  46. ; TRIM ARC IFF quadrant point is on arc
  47. (defun trimarc (ename cen rad sa ea quad)
  48.    (if (or
  49.           (<= sa quad ea)
  50.           (<= sa (+ quad d360) ea) )
  51.         (trim ename (polar cen quad rad)) ) )
  52. ;----------------------------------------------------------
  53. ; Crossing Selection
  54. (defun sscross (p0 p2 / ss1 ss2)
  55.       (setq
  56.          ss1 (ssget "c" p0 p2)
  57.          ss2 (ssget "w" p0 p2) )
  58.       (if (/= (sslength ss1) (sslength ss2))
  59.          (progn
  60.             (command "select" ss1 "r" ss2 "")
  61.             (setq
  62.                ss1 nil
  63.                ss2 nil )
  64.             (ssget "p") ) ) )
  65. ;----------------------------------------------------------
  66. ; Identify entities
  67. (defun id (ent / ename etype)
  68.    (setq
  69.       ename (item -1 ent)
  70.       etype (item 0 ent)
  71.    )
  72.    (if (= etype "ARC")
  73.       (list ename etype (item 50 ent) (item 51 ent)) ; sa & ea
  74.       (list ename etype)
  75.    )
  76. )
  77. ;----------------------------------------------------------
  78. ; CLIP
  79. (defun c:clip ( / myerror ss1 ss2 trimmed)
  80. ;
  81. ; ---------- Internal error handler
  82.       (defun myerror (s)
  83.          (if (/= S "Function cancelled")
  84.             (princ (strcat "\nError: " s)) )
  85.          (command)
  86.          (command)
  87.          (command "undo" "end" "undo" "back")
  88.          (moder)
  89.          (setq *error* olderr)
  90.          (princ) )
  91. ; ---------- Initialize
  92.    (setq
  93.       olderr   *error*
  94.       *error*  myerror
  95.       d0   0.0
  96.       d90  (* 0.5 pi)
  97.       d180 pi
  98.       d270 (* 1.5 pi)
  99.       d360 (* 2.0 pi) )
  100.    (modes '("CMDECHO" "HIGHLIGHT" "BLIPMODE" "OSMODE"))
  101.    (setvar "cmdecho" 0)
  102.    (setvar "blipmode" 0)
  103.    (setvar "osmode" 0)
  104.    (setq hm (getvar "highlight"))
  105.    (command "undo" "mark")
  106.    (command "layer" "set" "0" "on" "0" "")
  107.    ;
  108.    ; ---------- get clip box
  109.    (setq
  110.       p0  (getpoint "\nFirst corner: ")
  111.       ok  p0 )
  112.    (if ok
  113.      (progn
  114.        (initget (+ 1 32)) ; disallow nulls, draw crossing box
  115.        (setq
  116.           p2  (getcorner p0 "Other corner: ")
  117.           p1  (list (car p2) (cadr p0))
  118.           p3  (list (car p0) (cadr p2)) )
  119.        (if (setq ss1 (ssget "c" p0 p2))
  120.           (setq ok T)
  121.           (progn
  122.              (setq ok nil)
  123.              (princ "\nNothing selected!") ) ) ) )
  124.    (if ok
  125.      (progn
  126.        ; ---------- draw clip box
  127.        (setq midp (midpoint p0 p2))
  128.        (command "pline" p0 "w" 0 0 p1 p2 p3 "c")
  129.        (setq polyent (entlast))
  130.        ;
  131.        ; ---------- mark the last entity in the drawing
  132.        (command "point" "0,0")
  133.        (setq lastent (entlast))
  134.        (entdel lastent)
  135.        ;
  136.        ; ----------- move the clip to one side
  137.        (princ "\nLocation of clip: ")
  138.        (command "move" polyent "" midp pause)
  139.        (setq newpnt (getvar "lastpoint"))
  140.        (while (equal newpnt midp)
  141.          (command "undo" "1")
  142.          (princ "\nLocation of clip: ")
  143.          (command "move" polyent "" midp pause)
  144.          (setq newpnt (getvar "lastpoint"))
  145.        )
  146.        (setvar "highlight" 0)
  147.        (command "copy" ss1 "" midp newpnt)
  148.        (setvar "highlight" hm)
  149.        ;
  150.        ; ----------- get the new clip boundaries
  151.        (setq
  152.           ename (entnext polyent)
  153.           p0    (item 10 (entget ename))
  154.           ename (entnext (entnext ename))
  155.           p2    (item 10 (entget ename))
  156.           x0    (car p0)
  157.           x2    (car p2)
  158.           y0    (cadr p0)
  159.           y2    (cadr p2) )
  160.        (if (< x2 x0)
  161.          (setq
  162.             x0  (car p2)
  163.             x2  (car p0) ) )
  164.        (if (< y2 y0)
  165.          (setq
  166.            y0 (cadr p2)
  167.            y2 (cadr p0) ) )
  168.        ; ---------- explode everything we can, gather what we can't
  169.        (setq
  170.           ename lastent
  171.           ss2   (ssadd) )
  172.        (princ "\nGathering data... Please wait...")
  173.        (while (setq ename (entnext ename))
  174.           (setq
  175.              ent (entget ename)
  176.              etype (item 0 ent) )
  177.           (if (= hm 1) (redraw ename 3)) ; highlight entity
  178.           (cond
  179.              ((member etype '("POLYLINE"))
  180.               (command "explode" ename) )
  181.              ((ssadd ename ss2) ) ) )
  182.        ; ---------- remove everything outside the clip box
  183.        (setq
  184.          ss1 (ssget "c" p0 p2) )
  185.        (command "erase" ss2 "r" ss1 "")) )
  186.    ; ---------- do the trimming
  187.    (setq trimmed nil) ; list of trimmed circles, arcs
  188.    (while ok
  189.       ; ---------- form a selection set of objects
  190.       ;            crossing the border
  191.       (setq
  192.          ok  nil
  193.          i   0
  194.          ss1 (sscross p0 p2)
  195.          l   (if ss1
  196.                 (sslength ss1)
  197.                 0 ) )
  198.       ; ---------- trim each entity crossing the border
  199.       (if (> l 0)
  200.          (command "trim" polyent "")  )
  201.       (while (< i l)
  202.          (setq
  203.             ename (ssname ss1 i)
  204.             ent   (entget ename)
  205.             etype (item 0 ent) )
  206.          (if (not (member (id ent) trimmed)) ; if we trimmed this exact entity
  207.              (progn                          ;  don't trim it again
  208.                 (setq trimmed (cons (id ent) trimmed))
  209.                 (cond
  210.                    ((= etype "LINE") ; trim endpoints
  211.                     (trim ename (item 10 ent))
  212.                     (trim ename (item 11 ent)) )
  213.                    ((= etype "CIRCLE")
  214.                     (setq
  215.                        cen (item 10 ent)
  216.                        rad (item 40 ent)
  217.                        ok  T )
  218.                     (cond ; trim first quadrant outside border
  219.                      ( (trim ename (dxy cen rad     0.0   ))   )
  220.                      ( (trim ename (dxy cen 0.0     rad   ))   )
  221.                      ( (trim ename (dxy cen (- rad) 0.0   ))   )
  222.                      ( (trim ename (dxy cen 0.0     (- rad)))  )  ) )
  223.                    ((= etype "ARC")
  224.                     (setq
  225.                        cen (item 10 ent)
  226.                        rad (item 40 ent)
  227.                        sa  (item 50 ent)
  228.                        ea  (item 51 ent)
  229.                        ok  T )
  230.                     (if (> sa ea)
  231.                        (setq ea (+ ea d360)) )
  232.                     (cond ; trim first endpoint or quadrant outside border
  233.                       ((trim ename (polar cen sa rad))       )
  234.                       ((trim ename (polar cen ea rad))       )
  235.                       ((trimarc ename cen rad sa ea d0)      )
  236.                       ((trimarc ename cen rad sa ea d90)     )
  237.                       ((trimarc ename cen rad sa ea d180)    )
  238.                       ((trimarc ename cen rad sa ea d270)    ) ) ) ) ) )
  239.          (setq i (1+ i)) )
  240.       (if (> l 0) (command "")) )
  241.    ; ---------- erase any lines, circles, or arcs we left behind
  242.    (setq
  243.       i   0
  244.       ss1 (sscross p0 p2)
  245.       l   (if ss1
  246.              (sslength ss1)
  247.              0 ) )
  248.    (while (< i l)
  249.       (setq
  250.          ename (ssname ss1 i)
  251.          ent   (entget ename)
  252.          etype (item 0 ent) )
  253.       (if (member etype '("LINE" "CIRCLE" "ARC"))
  254.          (entdel ename) )
  255.       (setq i (1+ i)) )
  256.    ;
  257.    ; scale the clip
  258.    (setvar "highlight" 0)
  259.    (initget (+ 2 4)) ; disallow negative and zero inputs
  260.    (if (setq sf (getreal "\nScale factor <1.0000>: "))
  261.      (command "scale" "c" p0 p2 "" newpnt sf) )
  262.    (moder)                            ; Restore saved modes
  263.    (setq *error* olderr)              ; Restore old *error* handler
  264.    (princ)
  265. )
  266. (princ "\nCLIP.LSP -- Copyright 1988 by Looking Glass Microproducts\n")
  267. (c:clip)
  268.